home *** CD-ROM | disk | FTP | other *** search
/ CD ROM Paradise Collection 4 / CD ROM Paradise Collection 4 1995 Nov.iso / program / swagg_m.zip / GRAPHICS.SWG / 0159_Wormhole.pas < prev    next >
Pascal/Delphi Source File  |  1995-03-03  |  3KB  |  162 lines
  1. { Turbo Pascal version 7.0 directive settings }
  2. {$a+,b-,d+,e+,f-,g+,i+,l+,n-,o-,p-,q-,r-,s+,t-,v+,x+}
  3.  
  4. { if you have a 386 or better 'uncomment' the next line }
  5. {-$define cpu386}
  6.  
  7. program wormhole;
  8. { Asm-version of Wormhole, by Bas van Gaalen, Holland, PD }
  9. uses
  10.   crt;
  11. const
  12.   vidseg:word=$a000;
  13.   divd=128;
  14.   astep=6;
  15.   xst=4;
  16.   yst=5;
  17. var
  18.   sintab:array[0..449] of integer;
  19.   stab,ctab:array[0..255] of integer;
  20.   virscr:pointer;
  21.   virseg:word;
  22.   lstep:byte;
  23.  
  24. procedure setpal(col,r,g,b : byte); assembler;
  25. asm
  26.   mov dx,03c8h
  27.   mov al,col
  28.   out dx,al
  29.   inc dx
  30.   mov al,r
  31.   out dx,al
  32.   mov al,g
  33.   out dx,al
  34.   mov al,b
  35.   out dx,al
  36. end;
  37.  
  38. procedure drawpolar(xo,yo,r,a:word; c:byte; lvseg:word); assembler;
  39. asm
  40.   mov es,lvseg
  41.  
  42.   mov bx,a
  43.   add bx,a
  44.   mov cx,word ptr sintab[bx]
  45.   add bx,2*90
  46.   mov ax,word ptr sintab[bx]
  47.   mul r
  48.   mov bx,divd
  49.   xor dx,dx
  50.   cwd
  51.   idiv bx
  52.   add ax,xo
  53.   add ax,160
  54.   cmp ax,320
  55.   ja @out
  56.   mov si,ax
  57.  
  58.   mov ax,cx
  59.   mul r
  60.   mov bx,divd
  61.   xor dx,dx
  62.   cwd
  63.   idiv bx
  64.   add ax,yo
  65.   add ax,100
  66.   cmp ax,200
  67.   ja @out
  68.  
  69.   shl ax,6
  70.   mov di,ax
  71.   shl ax,2
  72.   add di,ax
  73.   add di,si
  74.   mov al,c
  75.   mov [es:di],al
  76.  @out:
  77. end;
  78.  
  79. procedure cls(lvseg:word); assembler;
  80. asm
  81.   mov es,[lvseg]
  82.   xor di,di
  83.   xor ax,ax
  84. {$ifdef cpu386}
  85.   mov cx,320*200/4
  86.   rep
  87.   db $66; stosw
  88. {$else}
  89.   mov cx,320*200/2
  90.   rep stosw
  91. {$endif}
  92. end;
  93.  
  94. procedure flip(src,dst:word); assembler;
  95. asm
  96.   push ds
  97.   mov ax,[dst]
  98.   mov es,ax
  99.   mov ax,[src]
  100.   mov ds,ax
  101.   xor si,si
  102.   xor di,di
  103. {$ifdef cpu386}
  104.   mov cx,320*200/4
  105.   rep
  106.   db $66; movsw
  107. {$else}
  108.   mov cx,320*200/2
  109.   rep movsw
  110. {$endif}
  111.   pop ds
  112. end;
  113.  
  114. procedure retrace; assembler;
  115. asm
  116.   mov dx,03dah
  117.  @vert1:
  118.   in al,dx
  119.   test al,8
  120.   jnz @vert1
  121.  @vert2:
  122.   in al,dx
  123.   test al,8
  124.   jz @vert2
  125. end;
  126.  
  127. var x,y,i,j:word; c:byte;
  128. begin
  129.   asm mov ax,13h; int 10h; end;
  130.   for i:=0 to 255 do begin
  131.     ctab[i]:=round(cos(pi*i/128)*60);
  132.     stab[i]:=round(sin(pi*i/128)*45);
  133.   end;
  134.   for i:=0 to 449 do sintab[i]:=round(sin(2*pi*i/360)*divd);
  135.   getmem(virscr,64000);
  136.   virseg:=seg(virscr^);
  137.   cls(virseg);
  138.   x:=30; y:=90;
  139.   repeat
  140.     {retrace;}
  141.     c:=22; lstep:=2; j:=10;
  142.     while j<220 do begin
  143.       i:=0;
  144.       while i<360 do begin
  145.         drawpolar(ctab[(x+(200-j)) mod 255],stab[(y+(200-j)) mod
  146. 255],j,i,c,virseg);
  147.         inc(i,astep);
  148.       end;
  149.       inc(j,lstep);
  150.       if (j mod 5)=0 then begin inc(lstep); inc(c); if c>31 then c:=22; end;
  151.     end;
  152.     x:=xst+x mod 255;
  153.     y:=yst+y mod 255;
  154.     flip(virseg,vidseg);
  155.     cls(virseg);
  156.   until keypressed;
  157.   while keypressed do readkey;
  158.   freemem(virscr,64000);
  159.   textmode(lastmode);
  160. end.
  161.  
  162.